{-# LANGUAGE RankNTypes                 #-}
{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  DirectoryDiff.BiParser
-- Copyright   :  (c) Stephen Tetley 2012
-- License     :  BSD3
--
-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
-- Stability   :  highly unstable
-- Portability :  GHC
--
-- Two continuation, two input-stream parser combinators!
-- 
--------------------------------------------------------------------------------

module DirectoryDiff.BiParser
  (
    Parser

  , Result(..)
  , ParseError

  , runParser

  , runParserEither

  , apply
  , failure
  , throwError
  , (<?>)
  , lookahead
  , peek
  , eof
  , anyToken
  , symbol
  , symbolL
  , symbolR
  , satisfy
  , prefix
  , prefix1
  , suffix
  , suffix1

--  , oneOf
--  , noneOf

  , chainl1
  , chainr1
  , chainl
  , chainr
  , choice
  , count
  , between
  , option
  , optionMaybe
  , optionUnit
  , skipOne
  , skipMany
  , skipMany1
  , many1
  , sepBy
  , sepBy1
  , sepEndBy
  , sepEndBy1
  , manyTill  
  , manyTill1
  , eitherOf

  ) where

import Control.Applicative
import Control.Monad



inputEOF :: [inp] -> [inp] -> Bool
inputEOF ls rs = null ls && null rs


data Result tok ans = Fail String | Okay ![tok] ![tok] ans 


type SK tok a ans = a -> FK tok ans -> [tok] -> [tok] -> Result tok ans
type FK tok ans   = Result tok ans


newtype Parser tok a = Parser { 
      getParser :: forall ans. 
                   SK tok a ans -> FK tok ans -> [tok] -> [tok] -> Result tok ans }


type ParseError   = String




runParser :: Parser tok a -> [tok] -> [tok] -> Result tok a
runParser p tls trs = getParser p skZero fkZero tls trs
  where
    skZero = \ans _ ls rs -> Okay ls rs ans
    fkZero = Fail ""




runParserEither :: Parser tok a -> [tok] -> [tok] -> Either ParseError a
runParserEither p ls rs = post $ runParser p ls rs
  where    
    post (Okay _ _ a)  = Right a
    post (Fail err)    = Left err




-- @return@ of Monad, @pure@ of Applicative
--
yield  :: a -> Parser tok a
yield a = Parser $ \sk fk ss -> sk a fk ss


-- mplus of MonadPlus, (<|>) of Applicative.
--
alt :: Parser tok a -> Parser tok a -> Parser tok a
alt p1 p2 = Parser $ \sk fk ls rs -> 
              getParser p1 sk (getParser p2 sk fk ls rs) ls rs


infixl 5 `apply`

apply :: Parser tok a -> (a -> b) -> Parser tok b
apply = flip fmap


failure :: Parser tok a
failure = Parser $ \_ fk _ _ -> fk


-- eager-many / zero-or-more (many of Applicative)
--
eagerMany :: Parser tok a -> Parser tok [a]
eagerMany p = (p >>= \z -> eagerMany p `apply` \zs -> (z:zs)) `alt` return [] 


-- eager-some / one-or-more (some of Applicative)
--
eagerSome :: Parser tok a -> Parser tok [a]
eagerSome p = p >>= \z -> eagerMany p `apply` \zs -> (z:zs)


instance Functor (Parser tok) where
  fmap f mf = Parser $ \sk -> getParser mf $ \a -> (sk . f) a
     


instance Applicative (Parser tok) where
  pure = yield
  (<*>) = ap

instance Alternative (Parser tok) where
  empty = failure
  (<|>) = alt
  many  = eagerMany
  some  = eagerSome

 
instance Monad (Parser tok) where
  return  = yield
  m >>= k = Parser $ \sk -> getParser m $ \a -> getParser (k a) sk


instance MonadPlus (Parser tok) where
  mzero = failure
  mplus = alt



--------------------------------------------------------------------------------
-- Combinators


throwError :: String -> Parser tok a
throwError err_msg = Parser $ \_ _ _ _ -> Fail err_msg


infixr 0 <?>

(<?>) :: Parser tok a -> String -> Parser tok a
p <?> err_msg = Parser $ \sk fk ls rs -> getParser p sk (swapMsg fk) ls rs
  where
    swapMsg (Fail _) = Fail err_msg
    swapMsg okay     = okay


-- | This one is from Chris Okasaki\'s \"Even Higher-Order 
-- Functions for Parsing\".
--
lookahead :: Parser tok a -> (a -> Parser tok b) -> Parser tok b 
lookahead p mf  = Parser $ \sk fk -> 
    getParser p (\a fk2 -> getParser (mf a) sk fk2) fk



-- | Peek tries the supplied parse, but does not consume input 
-- \*\* even when the parse succeeds \*\*.
--
peek :: Parser tok a -> Parser tok a
peek p = Parser $ \sk fk ls rs -> 
    getParser p (\a fk2 _ _ -> sk a fk2 ls rs) fk ls rs



eof :: Parser tok ()
eof = Parser go
  where
    go sk fk ls rs | inputEOF ls rs = sk () fk ls rs
    go _  fk _  _                   = fk


anyToken :: Eq tok => Parser tok tok
anyToken = Parser go
  where
   go sk fk (l:ls) (r:rs) | l == r = sk l fk ls rs
   go _  fk _      _               = fk 


symbol :: Eq tok => tok -> Parser tok tok
symbol tok = Parser go
  where
    go sk fk (l:ls) (r:rs) | l == tok && r == tok = sk l fk ls rs
    go _  fk _      _                             = fk

symbolL :: Eq tok => tok -> Parser tok tok
symbolL tok = Parser go
  where
    go sk fk (l:ls) rs | l == tok = sk l fk ls rs
    go _  fk _      _             = fk

symbolR :: Eq tok => tok -> Parser tok tok
symbolR tok = Parser go
  where
    go sk fk ls (r:rs) | r == tok = sk r fk ls rs
    go _  fk _  _                 = fk

satisfy :: (tok -> Bool) -> (tok -> tok -> a) -> Parser tok a 
satisfy test make = Parser go
  where
    go sk fk (l:ls) (r:rs) | test l && test r = sk (make l r) fk ls rs
    go _  fk _      _                         = fk

prefix :: Eq tok => Parser tok [tok]
prefix = many anyToken

prefix1 :: Eq tok => Parser tok [tok]
prefix1 = many1 anyToken

suffix :: Eq tok => Parser tok [tok]
suffix = many anyToken <* eof

suffix1 :: Eq tok => Parser tok [tok]
suffix1 = many1 anyToken <* eof

{-
oneOf           :: Eq tok => [tok] -> Parser tok tok
oneOf cs        = satisfy (`elem` cs) const



noneOf          :: [Char] -> Parser Char
noneOf cs       = satisfy (`notElem` cs)

-}

-- Note - the type sigs of the chain parsers can be generalized 
-- to any MonadPlus.
--

chainl1 :: MonadPlus m => m a -> m (a -> a -> a) -> m a
chainl1 p op = p >>= rest 
  where 
    rest x = mplus (op >>= \f -> p >>= \a -> rest (f x a)) (return x) 
               

chainr1 :: MonadPlus m => m a -> m (a -> a -> a) -> m a
chainr1 p op = scan 
   where 
     scan   = p >>= rest 
     rest x = mplus (op >>= \f -> scan >>= \a -> rest (f x a)) (return x) 

chainl :: MonadPlus m => m a -> m (a -> a -> a) -> a -> m a
chainl p op v = mplus (chainl1 p op) (return v)

chainr :: MonadPlus m => m a -> m (a -> a -> a) -> a -> m a
chainr p op v = mplus (chainr1 p op) (return v)


infixr 5 <:> 
 
-- | Applicative cons.
--
(<:>) :: Applicative f => f a -> f [a] -> f [a]
(<:>) p1 p2 = (:) <$> p1 <*> p2


choice :: Alternative f => [f a] -> f a
choice = foldr (<|>) empty 
   
count :: Applicative f => Int -> f a -> f [a]
count i p | i <= 0    = pure []
          | otherwise = p <:> count (i-1) p 
          
between :: Applicative f => f open -> f close -> f a -> f a
between o c a = o *> a <* c

          
option :: Alternative f => a -> f a -> f a
option x p          = p <|> pure x

optionMaybe :: Alternative f => f a -> f (Maybe a)
optionMaybe = optional

-- aka Parsecs /optional/
optionUnit :: Alternative f => f a -> f ()
optionUnit p = () <$ p <|> pure ()

skipOne :: Applicative f => f a -> f ()
skipOne p = p *> pure ()

skipMany :: Alternative f => f a -> f ()
skipMany p = many_p
  where 
    many_p = some_p <|> pure ()
    some_p = p       *> many_p

skipMany1 :: Alternative f => f a -> f ()
skipMany1 p = p *> skipMany p


-- | 'many1' an alias for Control.Applicative 'some'. 
--
many1 :: Alternative f => f a -> f [a]
many1 = some


sepBy :: Alternative f => f a -> f b -> f [a]
sepBy p sep = sepBy1 p sep <|> pure []

sepBy1 :: Alternative f => f a -> f b -> f [a]
sepBy1 p sep = p <:> step 
  where 
    step = (sep *> p) <:> step <|> pure []

sepEndBy :: Alternative f => f a -> f b -> f [a]
sepEndBy p sep = sepEndBy1 p sep <|> pure []

sepEndBy1 :: Alternative f => f a -> f b -> f [a]
sepEndBy1 p sep = (p <* sep) <:> step 
  where
    step = (p <* sep) <:> step <|> pure []
    
manyTill :: Alternative f => f a -> f b -> f [a]
manyTill p end = step <|> pure [] 
  where
    step  = p <:> (final <|> step)
    final = [] <$ end 

manyTill1 :: Alternative f => f a -> f b -> f [a]
manyTill1 p end = p <:> step 
  where
    step  = final <|> (p <:> step)
    final = [] <$ end


eitherOf :: Alternative f => f a -> f b -> f (Either a b)
eitherOf pa pb = (Left <$> pa) <|> (Right <$> pb) 
